home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.3 / ice-9 / getopt-gnu-style.scm.z / getopt-gnu-style.scm
Encoding:
Text File  |  1999-04-16  |  3.7 KB  |  96 lines
  1. ;;;; getopt-gnu-style.scm --- command-line argument parsing functions
  2. ;;;;
  3. ;;;;      Copyright (C) 1998 Free Software Foundation, Inc.
  4. ;;;;
  5. ;;;;   This file is part of GUILE.
  6. ;;;;   
  7. ;;;;   GUILE is free software; you can redistribute it and/or modify
  8. ;;;;   it under the terms of the GNU General Public License as
  9. ;;;;   published by the Free Software Foundation; either version 2, or
  10. ;;;;   (at your option) any later version.
  11. ;;;;   
  12. ;;;;   GUILE is distributed in the hope that it will be useful, but
  13. ;;;;   WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;;;;   GNU General Public License for more details.
  16. ;;;;   
  17. ;;;;   You should have received a copy of the GNU General Public
  18. ;;;;   License along with GUILE; see the file COPYING.  If not, write
  19. ;;;;   to the Free Software Foundation, Inc., 59 Temple Place, Suite
  20. ;;;;   330, Boston, MA 02111-1307 USA
  21. ;;;;
  22. ;;;; author:    russ mcmanus
  23. ;;;; Id: getopt-gnu-style.scm,v 1.5 1998/01/05 17:28:45 mcmanr Exp 
  24.  
  25. (define-module (ice-9 getopt-gnu-style))
  26.  
  27. (define (split-arg-list arg-ls)
  28.   "Given an arg-ls, decide which part to process for options.  
  29. Everything before an arg of \"--\" is fair game, everything 
  30. after it should not be processed.  the \"--\" is discarded.
  31. A cons pair is returned whose car is the list to process for
  32. options, and whose cdr is the list to not process."
  33.   (let loop ((process-ls '())
  34.          (not-process-ls arg-ls))
  35.     (cond ((null? not-process-ls)
  36.        (cons process-ls '()))
  37.       ((equal? "--" (car not-process-ls))
  38.        (cons process-ls (cdr not-process-ls)))
  39.       (#t
  40.        (loop (cons (car not-process-ls) process-ls)
  41.          (cdr not-process-ls))))))
  42.  
  43. (define arg-rx (make-regexp "^--[^=]+="))
  44. (define no-arg-rx (make-regexp "^--[^=]+$"))
  45.  
  46. (define (getopt-gnu-style arg-ls)
  47.   "Parse a list of program arguments into an alist of option descriptions.
  48.  
  49. Each item in the list of program arguments is examined to see if it
  50. meets the syntax of a GNU long-named option.  An argument like
  51. `--MUMBLE' produces an element of the form (MUMBLE . #t) in the
  52. returned alist, where MUMBLE is a keyword object with the same name as
  53. the argument.  An argument like `--MUMBLE=FROB' produces an element of
  54. the form (MUMBLE . FROB), where FROB is a string.
  55.  
  56. As a special case, the returned alist also contains a pair whose car
  57. is the symbol `rest'.  The cdr of this pair is a list containing all
  58. the items in the argument list that are not options of the form
  59. mentioned above.
  60.  
  61. The argument `--' is treated specially: all items in the argument list
  62. appearing after such an argument are not examined, and are returned in
  63. the special `rest' list.
  64.  
  65. This function does not parse normal single-character switches.  You
  66. will need to parse them out of the `rest' list yourself."
  67.   (let* ((pair (split-arg-list arg-ls))
  68.      (eligible-arg-ls (car pair))
  69.      (ineligible-arg-ls (cdr pair)))
  70.     (let loop ((arg-ls eligible-arg-ls)
  71.            (alist (list (cons 'rest ineligible-arg-ls))))
  72.       (if (null? arg-ls) alist
  73.       (let ((first (car arg-ls))
  74.         (rest (cdr arg-ls))
  75.         (result #f))
  76.         (cond ((begin (set! result (regexp-exec arg-rx first)) result)
  77.            (loop rest 
  78.              (cons (cons (symbol->keyword 
  79.                       (string->symbol
  80.                        (substring first 2 (- (cdr (vector-ref result 1)) 1))))
  81.                      (substring first (cdr (vector-ref result 1))))
  82.                    alist)))
  83.           ((begin (set! result (regexp-exec no-arg-rx first)) result)
  84.            (loop rest
  85.              (cons (cons (symbol->keyword
  86.                       (string->symbol
  87.                        (substring first 2 (cdr (vector-ref result 1)))))
  88.                      #t)
  89.                    alist)))
  90.           (#t
  91.            (let ((pair (assq 'rest alist)))
  92.              (set-cdr! pair (cons first (cdr pair)))
  93.              (loop rest alist)))))))))
  94.  
  95. (define-public getopt-gnu-style getopt-gnu-style)
  96.